home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / scsh / static.scm.in < prev    next >
Text File  |  1995-10-31  |  21KB  |  679 lines
  1. #!/usr/local/bin/scsh \
  2. -lm /usr/local/lib/scsh/vm/ps-interface.scm -lm /usr/local/lib/scsh/vm/interfaces.scm -lm /usr/local/lib/scsh/vm/package-defs.scm -lm /usr/local/lib/scsh/vm/s48-package-defs.scm -m heap -l /usr/local/lib/scsh/scsh/static-heap.scm -dm -m scsh-static-heap -e scsh-static-linker -s 
  3. !#
  4. ;;; Package for Static heaps for the Scheme Shell
  5. ;;; Copyright (c) 1995 by Brian D. Carlstrom.
  6.  
  7. ;;; based on Scheme48 implementation.
  8. ;;; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees.
  9.  
  10. (define-structure heap-extra (export newspace-begin
  11.                   heap-pointer
  12.                   header-a-units
  13.                   d-vector? 
  14.                   stob-type)
  15.   (open scheme heap)
  16.   (begin
  17.     (define (newspace-begin) *newspace-begin*)
  18.     (define (heap-pointer) *hp*)))
  19.  
  20. (define-structure scsh-static-heap (export scsh-static-linker)
  21.   (open scheme heap memory data stob struct
  22.     heap-extra
  23.     vm-architecture
  24.     formats
  25.     enumerated
  26.     signals
  27.     tables
  28.     defrec-package
  29.     scsh)
  30.   (begin
  31.  
  32.     (define (scsh-static-linker argl)
  33.       (if (not (= (length argl) 3))
  34.       (error "usage: ~a input-image-file output-archive-file" (car argl))
  35.       (let ((tempdir (or (getenv "TMPDIR")
  36.                  "@TMPDIR@"))
  37.         (cc-command (or (getenv "CC")
  38.                 "@CC@ @CFLAGS@"))
  39.         (ar-command (or (getenv "AR")
  40.                 "@AR@"))
  41.         (infile (cadr argl))
  42.         (outfile (caddr argl)))
  43.         (scsh-do-it infile tempdir outfile cc-command ar-command)
  44.         (exit 0))))
  45.  
  46.     ;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
  47.     (define-record heap
  48.       (length    0)
  49.       (objects '())
  50.       )
  51.     ;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
  52.     (define (scsh-do-it infile tempdir outfile cc-command ar-command)
  53.       (let* ((temp-dir (format #f "~a/scsh~s" tempdir (pid)))
  54.          (prefix (string-append temp-dir "/static"))
  55.          (start (read-heap-image infile)))
  56.     (receive (pure impure reloc externs)
  57.         (create-heaps-and-tables)
  58.       (if (file-exists? temp-dir)
  59.           (if (file-directory? temp-dir)
  60.           (with-cwd temp-dir
  61.                 (map delete-file (directory-files temp-dir #t)))
  62.           (delete-file temp-dir)))
  63.       (create-directory temp-dir #o755 #t)
  64.       (with-cwd temp-dir
  65.             (write-c-header-file pure impure externs infile outfile prefix)
  66.             (write-c-image pure impure reloc externs prefix)
  67.             (write-main-c-file start reloc prefix)
  68.             (compile-c-files cc-command prefix))
  69.       (archive-files ar-command outfile prefix)
  70.       )))
  71.  
  72.  
  73.     (define debug #f)
  74.  
  75.     (define (vm-string->string x)
  76.       (cond ((vm-string? x)
  77.          (let ((len (vm-string-length x)))
  78.            (let loop ((i 0) 
  79.               (l '()))
  80.          (cond ((= i len) 
  81.             (list->string (reverse l)))
  82.                (else
  83.             (loop (+ i 1) (cons (vm-string-ref x i) l)))))))
  84.         (else
  85.          (message x " is not a vm-string"))))
  86.  
  87.     (define (read-heap-image infile)
  88.       (let ((bytes (file-info:size (file-info infile))))
  89.     (init (inexact->exact (floor (* 1.1 bytes))) infile)))
  90.                     ; XXX need little extra space for find-all-xs
  91.  
  92.     (define (create-heaps-and-tables)
  93.       (let* ((n       (nchunks))
  94.          (  pure  (make-vector n))
  95.          (impure  (make-vector n))
  96.          (reloc   (make-vector n))
  97.          (externs (make-table   )))
  98.     ;; initialize to blanks
  99.     (let loop ((i 0))
  100.       (cond ((not (= i n))
  101.          (vector-set!   pure i (make-heap ))
  102.          (vector-set! impure i (make-heap ))
  103.          (vector-set!  reloc i (make-table))
  104.          (loop (+ i 1)))))
  105.     (scsh-for-each-stored-object
  106.      (lambda (chunk)
  107.        (format #t "Reading chunk number ~s" chunk))
  108.      (lambda (chunk x len)
  109.        (if debug
  110.            (write x))
  111.        (let* ((mutable (mutable? x))
  112.           (heap (vector-ref (if mutable impure pure) chunk)))
  113.          (table-set! (vector-ref reloc chunk) x (heap:length heap))
  114.          (set-heap:objects heap (cons x (heap:objects heap)))
  115.          (set-heap:length  heap (+ len  (heap:length  heap)))
  116.          (cond (debug
  117.             (display (if mutable "   mutable " " immutable "))
  118.             (cond ((d-vector? x)  (display " d-vector"))
  119.               ((vm-string? x) (display "vm-string"))
  120.               (else           (display " b-vector")))
  121.             (let ((m (heap:length (vector-ref impure chunk)))
  122.               (i (heap:length (vector-ref   pure chunk))))
  123.               (message " m" m "+i" i "=" (+ m i))))))
  124.        (if (= (header-type (stob-header x)) (enum stob external))
  125.            (table-set! externs 
  126.                (external-value x) 
  127.                (vm-string->string (external-name x))))
  128.        )
  129.      (lambda (chunk) 
  130.        (newline)))
  131.     (let loop ((i 0))
  132.       (cond ((not (= i n))
  133.          (let ((p (vector-ref   pure i))
  134.                (i (vector-ref impure i)))
  135.            (set-heap:objects p (reverse (heap:objects p)))
  136.            (set-heap:objects i (reverse (heap:objects i))))
  137.          (loop (+ i 1)))))
  138.     (values pure impure reloc externs)))
  139.  
  140.     (define (write-c-header-file pure impure externs infile outfile prefix)
  141.       (message "Writing header file")
  142.       (call-with-output-file (string-append prefix ".h")
  143.     (lambda (port)
  144.       (format port "/* Static Heap File Automatically Generated~%")
  145.       (format port " * by   scsh/static.scm~%")
  146.       (format port " * from ~a~%" infile)
  147.       (format port " * to   ~a~%" outfile)
  148.       (format port " */~%")
  149.       (let ((n (nchunks)))
  150.         (do ((i 0 (+ i 1)))
  151.         ((= i n))
  152.           (format port "extern const long p~s[~s];~%" i 
  153.               (quotient (heap:length (vector-ref   pure i)) 4)))
  154.         (do ((i 0 (+ i 1)))
  155.         ((= i n))
  156.           (format port "extern long i~s[~s];~%" i
  157.               (quotient (heap:length (vector-ref impure i)) 4))))
  158.       (table-walk
  159.        (lambda (address name)
  160.          (format port "const extern ~a();~%" name))
  161.        externs)
  162.       )))
  163.  
  164.     (define (d-vector-for-each proc d-vector)
  165.       (do ((i 0 (+ i 1)))
  166.       ((>= i (d-vector-length d-vector)))
  167.     (proc (d-vector-ref d-vector i))))
  168.  
  169.     (define (write-c-image pure impure reloc externs prefix)
  170.       (message "Writing   pure c files")
  171.       (scsh-write-c-image   pure "p" "const " reloc externs prefix)
  172.       (message "Writing impure c files")
  173.       (scsh-write-c-image impure "i" ""       reloc externs prefix))
  174.  
  175.     (define (scsh-write-c-image heap name const reloc externs prefix)
  176.       (let ((n (nchunks)))
  177.     (let chunk-loop ((c 0))
  178.       (cond ((not (= c n))
  179.          (format #t "Writing ~a-~a~s.c~%" prefix name c)
  180.          (call-with-output-file 
  181.              (format #f "~a-~a~s.c" prefix name c)
  182.            (lambda (port)         
  183.              (format port "#include \"~a.h\"~%" prefix)
  184.              (format port "~a long ~a~s[]={~%" const name c)
  185.              (let ((heap (vector-ref heap c)))
  186.                (let heap-loop ((l (heap:objects heap)))
  187.              (cond ((not (null? l))
  188.                 (scsh-emit-initializer (car l) reloc externs port)
  189.                 (heap-loop (cdr l))))))
  190.              (display "};" port)
  191.              (newline port)))
  192.          (chunk-loop (+ 1 c)))))))
  193.  
  194.     (define (write-main-c-file start reloc prefix)
  195.       (let ((n (nchunks)))
  196.     (call-with-output-file (string-append prefix ".c")
  197.       (lambda (port)
  198.         (format port "#include \"~a.h\"~%" prefix)
  199.         (format port "const long p_count = ~s;~%" n)
  200.         (format port "const long i_count = ~s;~%" n)
  201.         
  202.         (format port "const long * const p_areas[~s] = {" n)
  203.         (do ((i 0 (+ i 1)))
  204.         ((= i n))
  205.           (format port "(const long *) &p~s, " i))
  206.         (format port "};~%")
  207.  
  208.         (format port "long * const i_areas[~s] = {" n)
  209.         (do ((i 0 (+ i 1)))
  210.         ((= i n))
  211.           (format port "(long *) &i~s, " i))
  212.         (format port "};~%")
  213.  
  214.         (format port "const long p_sizes[~s] = {" n)
  215.         (do ((i 0 (+ i 1)))
  216.         ((= i n))
  217.           (format port "sizeof(p~s), " i))
  218.         (format port "};~%")
  219.  
  220.         (format port "const long i_sizes[~s] = {" n)
  221.         (do ((i 0 (+ i 1)))
  222.         ((= i n))
  223.           (format port "sizeof(i~s), " i))
  224.         (format port "};~%")
  225.  
  226.         (display "const long entry = " port)
  227.         (scsh-emit-descriptor start reloc port)
  228.         (write-char #\; port)
  229.         (newline port)))))
  230.  
  231.     (define (compile-c-files cc-command prefix)
  232.       (let ((n (nchunks))
  233.         (cc (line->list cc-command)))
  234.     (message "Compiling main C file")
  235.     (run (,@(append cc (list (format #f "~a.c" prefix)))))
  236.     (do ((i 0 (+ i 1)))
  237.         ((= i n))
  238.       (message "Compiling C file for   pure chunk " i)
  239.       (run (,@(append cc 
  240.               (list (format #f "~a-p~s.c" prefix i)))))
  241.       (message "Compiling C file for impure chunk " i)
  242.       (run (,@(append cc 
  243.               (list (format #f "~a-i~s.c" prefix i))))))))
  244.  
  245.     (define (archive-files ar-command outfile prefix)
  246.       (let ((n (nchunks))
  247.         (ar (line->list ar-command)))
  248.     (message "Archiving object files")
  249.     (run (,@(append 
  250.          ar
  251.          (cons 
  252.           outfile
  253.           (let loop ((i 0)
  254.                  (l '()))
  255.             (cond ((not (= i n))
  256.                (loop (+ i 1)
  257.                  (cons 
  258.                   (format #f "~a-i~s.o" prefix i)
  259.                   (cons
  260.                    (format #f "~a-p~s.o" prefix i)
  261.                    l))))
  262.               (else 
  263.                (reverse         
  264.                 (cons 
  265.                  (string-append prefix ".o")
  266.                  l)))))))))))
  267.  
  268.     (define (scsh-emit-initializer x reloc externs port)
  269.       (write-hex port (stob-header x))
  270.       (cond ((d-vector? x)
  271.          (scsh-emit-d-vector-initializer x reloc port))
  272.         ((vm-string? x)
  273.          (scsh-emit-vm-string-initializer x port))
  274.         (else
  275.          (scsh-emit-b-vector-initializer x reloc externs port)))
  276.       (if *comments?*
  277.       (begin (display " /* " port)
  278.          (writex x port)
  279.          (display " */" port)))
  280.       (newline port))
  281.  
  282.  
  283.     (define (scsh-emit-d-vector-initializer x reloc port)
  284.       (let ((len (d-vector-length x)))
  285.     (do ((i 0 (+ i 1)))
  286.         ((= i len))
  287.       (scsh-emit-descriptor (d-vector-ref x i) reloc port)
  288.       (write-char #\, port))))
  289.  
  290.     (define (scsh-emit-vm-string-initializer x port)
  291.       (let* ((len (vm-string-length x))    ; end is jawilson style hack
  292.          (end (- (cells->bytes (bytes->cells (+ len 1))) 4)))
  293.     (do ((i 0 (+ i 4)))
  294.         ((= i end) 
  295.          (case (- len end)
  296.            ((0)
  297.         (write-hex port 0))
  298.            ((1)
  299.         (write-hex
  300.          port
  301.          (net-to-host-32 (arithmetic-shift 
  302.                   (char->ascii (vm-string-ref x i)) 24))))
  303.            ((2)
  304.         (write-hex 
  305.          port
  306.          (net-to-host-32 
  307.           (bitwise-ior
  308.            (arithmetic-shift
  309.             (char->ascii (vm-string-ref x i))       24)
  310.            (arithmetic-shift
  311.             (char->ascii (vm-string-ref x (+ i 1))) 16)))))
  312.            ((3)
  313.         (write-hex
  314.          port
  315.          (net-to-host-32
  316.           (bitwise-ior
  317.            (bitwise-ior
  318.             (arithmetic-shift 
  319.              (char->ascii (vm-string-ref x i))       24)
  320.             (arithmetic-shift 
  321.              (char->ascii (vm-string-ref x (+ i 1))) 16))
  322.            (arithmetic-shift  
  323.             (char->ascii (vm-string-ref x (+ i 2)))  8)))))))
  324.       (write-hex port
  325.              (net-to-host-32 (bitwise-ior
  326.                       (bitwise-ior
  327.                        (arithmetic-shift 
  328.                     (char->ascii (vm-string-ref x i))       24)
  329.                        (arithmetic-shift 
  330.                     (char->ascii (vm-string-ref x (+ i 1))) 16))
  331.                       (bitwise-ior
  332.                        (arithmetic-shift 
  333.                     (char->ascii (vm-string-ref x (+ i 2)))  8)
  334.                        (char->ascii  (vm-string-ref x (+ i 3))))))
  335.              ))))
  336.  
  337.     (define (scsh-emit-b-vector-initializer x reloc externs port)
  338.       (cond ((and (code-vector? x)
  339.           (table-ref externs x)) =>
  340.           (lambda (name)
  341.             (format port "(long) *~a," name)))
  342.         (else 
  343.          (let* ((len (b-vector-length x)) ;end is jawilson style hack
  344.             (end (- (cells->bytes (bytes->cells (+ len 1))) 4)))
  345.            (do ((i 0 (+ i 4)))
  346.            ((= i end)
  347.             (case (- len end)
  348.               ((1)
  349.                (write-hex
  350.             port
  351.             (net-to-host-32 (arithmetic-shift (b-vector-ref x i) 24))))
  352.               ((2)
  353.                (write-hex 
  354.             port
  355.             (net-to-host-32
  356.              (bitwise-ior
  357.               (arithmetic-shift (b-vector-ref x i)       24)
  358.               (arithmetic-shift (b-vector-ref x (+ i 1)) 16)))))
  359.               ((3)
  360.                (write-hex
  361.             port
  362.             (net-to-host-32
  363.              (bitwise-ior
  364.               (bitwise-ior
  365.                (arithmetic-shift (b-vector-ref x i)       24)
  366.                (arithmetic-shift (b-vector-ref x (+ i 1)) 16))
  367.               (arithmetic-shift  (b-vector-ref x (+ i 2))  8)))
  368.             ))))
  369.          (write-hex 
  370.           port
  371.           (net-to-host-32 (bitwise-ior
  372.                    (bitwise-ior
  373.                     (arithmetic-shift (b-vector-ref x i)       24)
  374.                     (arithmetic-shift (b-vector-ref x (+ i 1)) 16))
  375.                    (bitwise-ior
  376.                     (arithmetic-shift (b-vector-ref x (+ i 2))  8)
  377.                     (b-vector-ref x (+ i 3))))))))
  378.          )))
  379.  
  380.     (define (scsh-emit-descriptor x reloc port)
  381.       (if (stob? x)
  382.       (let ((n (chunk-number x)))
  383.         (display "(long)(&" port)
  384.         (if (immutable? x)
  385.         (display "p" port)
  386.         (display "i" port))
  387.         (display n port)
  388.         (display "[" port)
  389.         (display (quotient (table-ref (vector-ref reloc n) x) 4) port)
  390.         (display "])+7" port))
  391.       (format port 
  392.           (if (negative? x) "-0x~a" "0x~a")
  393.           (number->string (abs x) 16))))
  394.  
  395.     (define (scsh-for-each-stored-object chunk-start proc chunk-end)
  396.       (let ((limit (heap-pointer)))
  397.     (let chunk-loop ((addr (newspace-begin))
  398.              (i 0)
  399.              (chunk (+ (newspace-begin) *chunk-size*)))
  400.       (if (addr< addr limit)
  401.           (begin (chunk-start i)
  402.              (let loop ((addr addr))
  403.                (if (and (addr< addr limit)
  404.                 (addr< addr chunk))
  405.                (let* ((d   (fetch addr))
  406.                   (len (addr1+ (header-a-units d))))
  407.                  (if (not (header? d))
  408.                  (warn "heap is in an inconsistent state" d))
  409.                  (proc i (address->stob-descriptor (addr1+ addr)) len)
  410.                  (loop (addr+ addr len)))
  411.                (begin (chunk-end i)
  412.                   (chunk-loop addr
  413.                           (+ i 1)
  414.                           (+ chunk *chunk-size*))))))))))
  415.  
  416.     (define (write-hex port x) 
  417.       (format port 
  418.           (if (negative? x) "-0x~a," "0x~a,")
  419.           (number->string (abs x) 16)))
  420.  
  421.     ;; takes a string and break it into a list at whitespace
  422.     ;; rewrite using scsh stuff?
  423.     (define (line->list line)
  424.       (let ((len (string-length line)))
  425.     (let loop ((start 0)
  426.            (end 0)
  427.            (l '()))
  428.       (cond ((>= end len)
  429.          (if (= start end)
  430.              l
  431.              (append l (list (substring line start end)))))
  432.         ((and (= start end)
  433.               (or (char=? (string-ref line start) (ascii->char 32))
  434.               (char=? (string-ref line start) (ascii->char 9))))
  435.          (loop (+ 1 start) 
  436.                (+ 1 end) 
  437.                l))
  438.         ((or (char=? (string-ref line end) (ascii->char 32))
  439.              (char=? (string-ref line end) (ascii->char 9)))
  440.          (loop (+ 1 end) 
  441.                (+ 1 end) 
  442.                (append l (list (substring line start end)))))
  443.         ((< end len)
  444.          (loop start 
  445.                (+ 1 end)
  446.                l))
  447.         (else (error "unexpected case in line->list"))))))
  448.  
  449. ;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
  450. ;;; Debugging
  451. ;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
  452.  
  453.     (define (bin n)
  454.       (number->string n 2))
  455.  
  456.     (define (oct n)
  457.       (number->string n 8))
  458.  
  459.     (define (dec n)
  460.       (number->string n 10))
  461.  
  462.     (define (hex n)
  463.       (number->string n 16))
  464.  
  465. ;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
  466.  
  467.     ; For example:
  468.     ;   (do-it 100000 "~/s48/debug/little.image" "little-heap.c")
  469.     ;
  470.     ; The first argument to do-it should be somewhat larger than the size,
  471.     ; in bytes, of the image file to be converted (which you can obtain with
  472.     ; "ls -l").
  473.     ;
  474.     ; If the image contains 0-length stored objects, then the .c file will
  475.     ; have to be compiled by gcc, since 0-length arrays aren't allowed in
  476.     ; ANSI C.  This wouldn't be difficult to work around.
  477.     
  478.     (define *comments?* #f)
  479.     
  480.     ; 800,000 bytes => 200,000 words => at least 100,000 objects
  481.     ;   50 chunks => 16,000 bytes per chunk => 2,000 objects per chunk
  482.     (define *chunk-size* 10000)
  483.  
  484.     (define (do-it bytes infile outfile)
  485.       (let ((start (init bytes infile)))
  486.     (call-with-output-file outfile
  487.       (lambda (port)
  488.         (format port "#define D(x) (long)(&x)+7~%")
  489.         (format port "#define H unsigned long~%")
  490.         (emit-area-declarations "p" immutable? "const " port)
  491.         (emit-area-declarations "i" mutable? "" port)
  492.         (emit-area-initializers "p" immutable? "const " port)
  493.         (emit-area-initializers "i" mutable? "" port)
  494.         (display "const long entry = " port)
  495.         (emit-descriptor start port)
  496.         (write-char #\; port)
  497.         (newline port)))))
  498.  
  499.     (define (init bytes infile)
  500.       (create-memory (quotient bytes 2) quiescent) ;Output of ls -l
  501.       (initialize-heap (memory-begin) (memory-size))
  502.       (let ((start (read-image infile 0)))
  503.     (message (nchunks)
  504.          " chunks")
  505.     start))
  506.  
  507.     (define (nchunks) (+ (chunk-number (heap-pointer)) 1))
  508.  
  509.                     ; emit struct declarations for areas
  510.  
  511.     (define (emit-area-declarations name in-area? const port)
  512.       (for-each-stored-object
  513.        (lambda (chunk)
  514.      (message name chunk " declaration")
  515.      (display "struct " port) (display name port) (display chunk port)
  516.      (display " {" port) (newline port))
  517.        (lambda (x)
  518.      (if (in-area? x)
  519.          (emit-declaration x port)))
  520.        (lambda (chunk)
  521.      (display "};" port)
  522.      (newline port)
  523.      (display const port)
  524.      (display "extern struct " port) (display name port) (display chunk port)
  525.      (write-char #\space port) (display name port) (display chunk port)
  526.      (write-char #\; port) (newline port)
  527.      chunk)))
  528.  
  529.     (define (emit-declaration x port)
  530.       (display "  H x" port)
  531.       (writex x port)
  532.       (cond ((d-vector? x)
  533.          (display "; long d" port)
  534.          (writex x port)
  535.          (write-char #\[ port)
  536.          (write (d-vector-length x) port))
  537.         ((vm-string? x)
  538.          (display "; char d" port)
  539.          (writex x port)
  540.          (write-char #\[ port)
  541.          ;; Ensure alignment (thanks Ian)
  542.          (write (cells->bytes (bytes->cells (b-vector-length x)))
  543.             port))
  544.         (else
  545.          (display "; unsigned char d" port)
  546.          (writex x port)
  547.          (write-char #\[ port)
  548.          ;; Ensure alignment
  549.          (write (cells->bytes (bytes->cells (b-vector-length x)))
  550.             port)))
  551.       (display "];" port)
  552.       (if *comments?*
  553.       (begin (display " /* " port)
  554.          (display (enumerand->name (stob-type x) stob) port)
  555.          (display " */" port)))
  556.       (newline port))
  557.  
  558.                     ; Emit initializers for areas
  559.  
  560.     (define (emit-area-initializers name in-area? const port)
  561.       (for-each-stored-object
  562.        (lambda (chunk)
  563.      (message name chunk " initializer")
  564.  
  565.      (display const port)
  566.      (display "struct " port) (display name port) (write chunk port)
  567.      (write-char #\space port) (display name port) (write chunk port)
  568.      (display " =" port) (newline port)
  569.  
  570.      (write-char #\{ port) (newline port))
  571.        (lambda (x)
  572.      (if (in-area? x)
  573.          (emit-initializer x port)))
  574.        (lambda (chunk)
  575.      (display "};" port) (newline port)))
  576.  
  577.       (let ((n (nchunks)))
  578.     (format port "const long ~a_count = ~s;~%" name n)
  579.     (format port "~a long * const ~a_areas[~s] = {" const name n)
  580.     (do ((i 0 (+ i 1)))
  581.         ((= i n))
  582.       (format port "(~a long *)&~a~s, " const name i))
  583.     (format port "};~%const long ~a_sizes[~s] = {" name n)
  584.     (do ((i 0 (+ i 1)))
  585.         ((= i n))
  586.       (format port "sizeof(~a~s), " name i))
  587.     (format port "};~%")))
  588.  
  589.  
  590.     (define (message . stuff)
  591.       (for-each display stuff) (newline))
  592.  
  593.     (define (emit-initializer x port)
  594.       (display "  " port)
  595.       (write (stob-header x) port)
  596.       (write-char #\, port)
  597.       (cond ((d-vector? x)
  598.          (emit-d-vector-initializer x port))
  599.         ((vm-string? x)
  600.          (write-char #\" port)
  601.          (let ((len (vm-string-length x)))
  602.            (do ((i 0 (+ i 1)))
  603.            ((= i len) (write-char #\" port))
  604.          (let ((c (vm-string-ref x i)))
  605.            (cond ((or (char=? c #\") (char=? c #\\))
  606.               (write-char #\\ port))
  607.              ((char=? c #\newline)
  608.               (display "\\n\\" port)))
  609.            (write-char c port)))))
  610.         (else
  611.          (write-char #\{ port)
  612.          (let ((len (b-vector-length x)))
  613.            (do ((i 0 (+ i 1)))
  614.            ((= i len) (write-char #\} port))
  615.          (write (b-vector-ref x i) port)
  616.          (write-char #\, port)))))
  617.       (write-char #\, port)
  618.       (if *comments?*
  619.       (begin (display " /* " port)
  620.          (writex x port)
  621.          (display " */" port)))
  622.       (newline port))
  623.  
  624.     (define (emit-d-vector-initializer x port)
  625.       (write-char #\{ port)
  626.       (let ((len (d-vector-length x)))
  627.     (do ((i 0 (+ i 1)))
  628.         ((= i len) (write-char #\} port))
  629.       (emit-descriptor (d-vector-ref x i) port)
  630.       (write-char #\, port))))
  631.  
  632.     (define (emit-descriptor x port)
  633.       (if (stob? x)
  634.       (begin (if (immutable? x)
  635.              (display "D(p" port)
  636.              (display "D(i" port))
  637.          (display (chunk-number x) port)
  638.          (display ".x" port)
  639.          (writex x port)
  640.          (write-char #\) port))
  641.       (write x port)))
  642.  
  643.  
  644.                     ; Foo
  645.  
  646.     (define (writex x port)
  647.       (write (quotient (- (- x (memory-begin)) 7) 4) port))
  648.  
  649.     (define (chunk-number x)
  650.       (quotient (- (- x (memory-begin)) 7) *chunk-size*))
  651.  
  652.  
  653.                     ; Image traversal utility
  654.  
  655.     (define (for-each-stored-object chunk-start proc chunk-end)
  656.       (let ((limit (heap-pointer)))
  657.     (let chunk-loop ((addr (newspace-begin))
  658.              (i 0)
  659.              (chunk (+ (newspace-begin) *chunk-size*)))
  660.       (if (addr< addr limit)
  661.           (begin (chunk-start i)
  662.              (let loop ((addr addr))
  663.                (if (and (addr< addr limit)
  664.                 (addr< addr chunk))
  665.                (let ((d (fetch addr)))
  666.                  (if (not (header? d))
  667.                  (warn "heap is in an inconsistent state" d))
  668.                  (proc (address->stob-descriptor (addr1+ addr)))
  669.                  (loop (addr1+ (addr+ addr (header-a-units d)))))
  670.                (begin (chunk-end i)
  671.                   (chunk-loop addr
  672.                           (+ i 1)
  673.                           (+ chunk *chunk-size*))))))))))
  674.  
  675.     (define (mutable? x) (not (immutable? x)))
  676.  
  677.     ;; End begin
  678.     ))
  679.